Libris Britannia 4/science library(b).zip/science library(b)/MEDICAL/H121A.ZIP/FILES6.EXE/lha/ENTFACE.PAS

Pascal/Delphi Source File | 1991-07-15 | 12KB | 387 lines

{$R-}    {Range checking off}
{$B+}    {Boolean complete evaluation on}
{$S+}    {Stack checking on}
{$I+}    {I/O checking on}
{$N+}    {No numeric coprocessor}
{$E+}    {Emulation on}
{$V-}    {No string type checking}
Unit EntFace;
{This unit provides routines for any Turbo Pascal (version 5) program
 to install a vector to it's entry point at interrupt 75, and to
 access the data structures FieldList and FieldRecord.  These form
 a linked list of information about all fields in the current
 questionnaire in ENTER.  The routines FindField, GetString, GetNumber,
 PutString, and PutNumber allow access to the FieldList record for
 a named field, and transfer values from (Get) and to (Put) the
 questionnaire field in ENTER.}

  Interface

    Uses
      Crt, Dos;

    Type
      Float = Double; { 8 byte real, requires 8087 math chip, or
                        software emulation }

    const
      TNNearlyZero = 1E-015;
      Infinity     = 1E+50;
      RealSize     = 8;
      EnterError   = 1;

  Type
    String80    = String [80];
    String20    = String [20];
    Alfa        = Packed Array [1 .. 10] of Char;
    Byte        = 0 .. 255;
    EntryType   = (Numeric, Alpha, Date, Uppercase, CheckBox, YesNo,
                   RealNum, PhoneNum, Time, LocalNum, TodayType, EuroDate,
                   IDNum, Res4, Res5);
    ValueRecord = Packed Record
                    Case Integer of
                      0: (IntVal  : Integer);
                      1: (RealVal : Float);
                      2: (StrVal  : String20)
                  End (*ValueRecord*);
    LegalPtr    = ^ LegalRecord;
    LegalRecord = Packed Record
                    Value      : ValueRecord;
                    NewValue   : ValueRecord;
                    IsNew      : Boolean;
                    Next       : LegalPtr
                  End (*LegalRecord*);
    FieldPtr    = ^ FieldList;
    FieldRecord = Record
                    EntryKind  : EntryType;
                    EntryLen   : Byte (* 0 means no entry for this field *);
                    Name       : Alfa;
                    MustEnter  : Boolean;
                    Repeated   : Boolean;
                    QuestionX  : Byte;
                    QuestionY  : Integer;
                    QuestionC  : Byte;
                    EntryX     : Byte;
                    EntryY     : Integer;
                    EntryColor : Byte;
                    FieldChar  : Char;
                    Hidden     : Boolean;
                    Decimals   : Byte;
                    HasMin     : Boolean;
                    FieldMin   : ValueRecord;
                    HasMax     : Boolean;
                    FieldMax   : ValueRecord;
                    Legal      : LegalPtr;
                    Jumps      : LegalPtr;
                    Codes      : LegalPtr;
                    CodeField  : FieldPtr;
                    AutoJump   : FieldPtr;
                    BeforeCmds : Pointer;
                    AfterCmds  : Pointer;
                    Question   : String80
                  End;
    FieldList   = Record
                    Previous     : FieldPtr;
                    Next         : FieldPtr;
                    Missing      : Boolean;
                    FieldInt     : Integer;
                    FieldReal    : Float;
                    FieldEntry   : String80;
                    Field        : FieldRecord
                  End;

  {The following routines are available for communication between the ENTER
  program and the TSR program written in Turbo Pascal, Version 5}


  Function FindField (Header : FieldPtr; Field : String) : FieldPtr;
  {Returns a pointer to the FieldList record for the field named in Field}

  Function InstallInterrupt (IntNo : Integer; ProcPtr : Pointer) : Integer;
  {Installs an interrupt of the IntNo given.  The interrupt vector will
   be ProcPtr, the entry point of your program}

  Function GetString (Header : FieldPtr; QField : String) : String;
  {Returns a string from a field in the questionnaire}

  Function GetNumber (Header : FieldPtr; QField : String) : Float;
  {Returns a number from a field in the questionnaire}

  Procedure PutString (Header : FieldPtr; QField : String; S : String);
  {Places S in the named questionnaire field}

  Procedure PutNumber (Header : FieldPtr; QField : String; R : Float);
  {Places a number, R, in the named questionnaire field}


  Var
    EnterResult : Integer;

  Implementation

  Procedure MakeAlfa (S : String80; VAR A : Alfa);

    Var
      I : Integer;

    Begin
      A := '          ';
      For I := 1 to Length (S) Do
        If I <= 10
        Then
          A [I] := UpCase (S [I])
    End (*MakeAlfa*);

  Procedure MakeString (VAR S : String80; A : Alfa);

    Var
      I : Integer;

    Begin
      S := '';
      For I := 1 to 10 Do
        If A [I] <> ' '
        Then
          S := S + A [I]
    End (*MakeString*);

Function FindField (Header : FieldPtr; Field : String) : FieldPtr;
(*********************************************************************
 * FindField returns a pointer to the field having name = FieldName. *
 * If no such field exists in the list pointed to by header then     *
 * NIL is returned.                                                  *
 *********************************************************************)

  Var
    FPtr  : FieldPtr;
    Found : Boolean;
    Fieldname : Alfa;
    ch : Char;
    var I : integer;

  Begin
    FPtr := Header;
    Found := False;
    MakeAlfa (Field, Fieldname);
      {Convert fieldname to array and pad with spaces to 10 characters}
    Repeat
      If FPtr ^.Field.Name = FieldName
      Then
        Found := True
      Else
        FPtr := FPtr ^.Next
    Until Found or (FPtr = Header);
    If Found
    Then
      FindField := FPtr
    Else
      begin
        FindField := NIL;
        GotoXY (1,25);
        Write
 ('Field ',Field,' not found. Please check TSR program and questionnaire.');
        ch := readkey;
      end;
  End (*FindField*);

Function InstallInterrupt (IntNo : Integer; ProcPtr : Pointer) : Integer;

    Type
      InterruptRecPtr  = ^ InterruptRec;
      InterruptRec     = Packed Record
                           JmpInst      : Byte;
                           OldInt       : Pointer;
                           IDString     : Array [1 .. 5] of Char;
                           OldDSValue   : Word;
                           EnterRoutine : Pointer
                         End (*InterruptRec*);

    Const
      InterruptRoutine : InterruptRec =
                           (JmpInst:      $EA;
                            OldInt:       NIL;
                            IDString:     'ENTER';
                            OldDSValue:   0;
                            EnterRoutine: NIL);

    Var
      Dummy : Pointer;

    Function GetDSValue : Word;

      Inline ($8C/$D8)   {MOV   AX,DS};

    Begin
      GetIntVec (IntNo, Dummy);
      If InterruptRecPtr (Dummy) ^.IDString = 'ENTER'
      Then
        InstallInterrupt := 1
      Else
        Begin
          InterruptRoutine.OldInt := Dummy;
          InterruptRoutine.EnterRoutine := ProcPtr;
          InterruptRoutine.OldDSValue := GetDSValue;
          SetIntVec (IntNo, @InterruptRoutine);
          InstallInterrupt := 0
        End (*Else*)
    End (*InstallInterrupt*);

Function GetString (Header : FieldPtr; QField : String) : String;
  {Returns a string from a field in the questionnaire}
 Var FPtr : FieldPtr;

    Begin
      FPtr := FindField (Header, QField);
      With FPtr ^ Do
        If Missing
        Then
          GetString := ''
        Else
          GetString := FieldEntry
    End (*GetString*);

Function GetNumber (Header : FieldPtr; QField : String) : Float;
  {Returns a number from a field in the questionnaire}

 Var FPtr : FieldPtr;

    Begin
      FPtr := FindField (Header, QField);
      GetNumber := 0;
      With FPtr ^ Do
        If Not Missing
        Then
          Case Field.EntryKind of
            Numeric:
              GetNumber := FieldInt;
            RealNum:
              GetNumber := FieldReal;
            Else
              EnterResult := EnterError
          End (*Case*)
    End (*GetNumber*);

Function TruncDecimals (R : Float; NumDecimals : Integer) : Float;

    Var
      Temp : Float;

    Begin
      Temp := 1;
      While (NumDecimals > 0) Do
        Begin
          Temp := Temp * 10;
          Dec (NumDecimals)
        End (*While*);
      R := Round (R * Temp);
      TruncDecimals := R / Temp
    End (*TruncDecimals*);


Procedure PutString (Header : FieldPtr; QField : String; S : String);
  {Places S in the named questionnaire field}

    Var
      I, J : Integer;
      R    : Float;
      FPtr : FieldPtr;

    Begin
      FPtr := FindField (Header, QField);
      With FPtr ^ Do
        If S = ''
        Then
          Begin
            Missing := True;
            FieldEntry := ''
          End (*If*)
        Else
          Begin
            J := 0;
            Case Field.EntryKind of
              Numeric:
                Begin
                  Val (S, I, J);
                  If J = 0
                  Then
                    PutNumber (Header, QField, I)
                End (*Numeric*);
              RealNum:
                Begin
                  Val (S, R, J);
                  If J = 0
                  Then
                    PutNumber (Header, QField, R)
                End (*RealNum*);
              Else
                Begin
                  If Length (S) > Field.EntryLen
                  Then
                    S [0] := Chr (Field.EntryLen);
                  FieldEntry := S
                End (*Else*)
            End (*Case*);
            If J <> 0
            Then
              EnterResult := EnterError
          End (*Else*)
    End (*PutString*);

  Function MakeStringFromReal (R : Float; Width : Integer) : String;

    Var
      S : String;
      SLen : Byte Absolute S;

    Begin
      Str (R: Width*2: Width, S);
      While (S [SLen] = '0') Do
        Dec (SLen);
      If S [SLen] = '.'
      Then
        Dec (SLen);
      While (S [1] = ' ') And (SLen > 0) Do
        Delete (S, 1, 1);
      MakeStringFromReal := S
    End (*MakeStringFromReal*);


Procedure PutNumber (Header : FieldPtr; QField : String; R : Float);
  {Places a number, R, in the named questionnaire field}


    Var
      I : Integer;
   FPtr : FieldPtr;

    Begin
      FPtr := FindField (Header, QField);
      With FPtr ^ Do
        Begin
          Missing := False;
          Case Field.EntryKind of
            Numeric:
              Begin
                I := Round (R);
                Str (I: Field.EntryLen, FieldEntry);
                FieldInt := I;
              End (*Numeric*);
            RealNum:
              begin
                If Field.Decimals > 0 Then
                  Begin
                    R := TruncDecimals (R, Field.Decimals);
                    Str (R: Field.EntryLen: Field.Decimals, FieldEntry)
                  End (*If*)
                Else
                  FieldEntry := MakeStringFromReal (R, Field.EntryLen);
                FieldReal := R;
              end;
            Else
              FieldEntry := MakeStringFromReal (R, Field.EntryLen)
          End (*Case*)
        End (*With*)
    End (*PutNumber*);

End.  (*ENTFACE.PAS*)